home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / forth / amiga / amigaker.arc / 13.dict < prev    next >
Text File  |  1987-12-30  |  10KB  |  261 lines
  1. ;
  2. ;  13.dictionary
  3. ;
  4. ;
  5.  
  6.  
  7. * traverse        (s addr direction -- addr' ) Run through a name field
  8. ; in the specified direction ( +1 or -1 ) and return address of the fisrt
  9. ; byte whose high bit is set.
  10.                   dc.w     -1
  11.                   dc.l     link0
  12. link0             set      *-4
  13.                   dc.b     $88,'travers',$80!'e'
  14.                   cnop     0,2
  15. _traverse         dc.l     *+4
  16.                   move.l   (sp)+,d0
  17.                   move.l   (sp)+,a0
  18. 1$                adda.l   d0,a0
  19.                   tst.b    (a0)
  20.                   bpl.s    1$
  21.                   move.l   a0,-(sp)
  22.                   jmp      (a3)
  23.  
  24. * done?           (s n -- f ) True if the input is exhausted or if
  25. ; the state doesn't match.
  26.                   dc.w     -1
  27.                   dc.l     link0
  28. link0             set      *-4
  29.                   dc.b     $85,'done',$80!'?'
  30.                   cnop     0,2
  31. _done_question    dc.l     nest
  32.                   dc.l     _state,_fetch,_not_equals
  33.                   dc.l     _end_question,_fetch,_or
  34.                   dc.l     _end_question,_off,_exit
  35.  
  36. * n>link          Go from name field to link field.
  37.                   dc.w     -1
  38.                   dc.l     link2
  39. link2             set      *-4
  40.                   dc.b     $86,'n>lin',$80!'k'
  41.                   cnop     0,2
  42. _n_to_link        dc.l     nest
  43.                   dc.l     _4_minus,_exit
  44.  
  45. * l>name          Go from link field to name field.
  46.                   dc.w     -1
  47.                   dc.l     link0
  48. link0             set      *-4
  49.                   dc.b     $86,'l>nam',$80!'e'
  50.                   cnop     0,2
  51. _l_to_name        dc.l     nest
  52.                   dc.l     _4_plus,_exit
  53.  
  54. * body>           Go from body to code field.
  55.                   dc.w     -1
  56.                   dc.l     link2
  57. link2             set      *-4
  58.                   dc.b     $85,'body',$80!'>'
  59.                   cnop     0,2
  60. _body_from        dc.l     nest
  61.                   dc.l     _4_minus,_exit
  62.  
  63. * name>           Go from name to code field.
  64.                   dc.w     -1
  65.                   dc.l     link2
  66. link2             set      *-4
  67.                   dc.b     $85,'name',$80!'>'
  68.                   cnop     0,2
  69. _name_from        dc.l     nest
  70.                   dc.l     _1,_traverse,_1_plus
  71.                   dc.l     _even,_exit
  72.  
  73. * link>           Go from link field to code field.
  74.                   dc.w     -1
  75.                   dc.l     link0
  76. link0             set      *-4
  77.                   dc.b     $85,'link',$80!'>'
  78.                   cnop     0,2
  79. _link_from        dc.l     nest
  80.                   dc.l     _l_to_name,_name_from,_exit
  81.  
  82. * >body           Go from code field to body.
  83.                   dc.w     -1
  84.                   dc.l     link2
  85. link2             set      *-4
  86.                   dc.b     $85,'>bod',$80!'y'
  87.                   cnop     0,2
  88. _to_body          dc.l     nest
  89.                   dc.l     _4_plus,_exit
  90.  
  91. * >name           Go from code field to name field.
  92.                   dc.w     -1
  93.                   dc.l     link2
  94. link2             set      *-4
  95.                   dc.b     $85,'>nam',$80!'e'
  96.                   cnop     0,2
  97. _to_name          dc.l     nest
  98.                   dc.l     _minus_1,_traverse,_minus_1,_traverse,_exit
  99.  
  100. * >link           Go from code field to link field.
  101.                   dc.w     -1
  102.                   dc.l     link2
  103. link2             set      *-4
  104.                   dc.b     $85,'>lin',$80!'k'
  105.                   cnop     0,2
  106. _to_link          dc.l     nest
  107.                   dc.l     _to_name,_n_to_link,_exit
  108.  
  109. * >view           Go from code field to view field.
  110.                   dc.w     -1
  111.                   dc.l     link2
  112. link2             set      *-4
  113.                   dc.b     $85,'>vie',$80!'w'
  114.                   cnop     0,2
  115. _to_view          dc.l     nest
  116.                   dc.l     _to_link,_2_minus,_exit
  117.  
  118. * view>           go from view field to code field.
  119.                   dc.w     -1
  120.                   dc.l     link2
  121. link2             set      *-4
  122.                   dc.b     $85,'view',$80!'>'
  123.                   cnop     0,2
  124. _view_from        dc.l     nest
  125.                   dc.l     _2_plus,_link_from,_exit
  126.  
  127. * hash            (s string voc-ptr -- thread ) This word indexes the
  128. ; voc-ptr to point to the start of a vocabulary linked list. This hash
  129. ; function uses the first character of the string as the function.
  130. ; Currently only 4 links are used. The function uses the two lower bits
  131. ; as the index.
  132.                   dc.w     -1
  133.                   dc.l     link0
  134. link0             set      *-4
  135.                   dc.b     $84,'has',$80!'h'
  136.                   cnop     0,2
  137. _hash             dc.l     *+4
  138.                   move.l   (sp)+,d0          ;get voc-ptr
  139.                   move.l   (sp),a0           ;string
  140.                   addq.l   #1,a0             ;step over length
  141.                   moveq    #3,d1             ;prepare mask
  142.                   and.b    (a0),d1           ;mask of 3 bits in char
  143.                   asl.l    #2,d1             ;times 4
  144.                   add.l    d1,d0
  145.                   move.l   d0,(sp)
  146.                   jmp      (a3)
  147.  
  148. * (find)          (s here lfa -- here false | cfa flag )
  149. ; Attempts to find a match between the string at here and the dictionary
  150. ; linked list lfa. If not found the string address is returned with a (0)
  151. ; false flag.
  152. ; If found the Code Field Address is returned together with +1 if the word
  153. ; is immediate, -1 if the word is not immediate.
  154.                   dc.w     -1
  155.                   dc.l     link0
  156. link0             set      *-4
  157.                   dc.b     $86,'(find',$80!')'
  158.                   cnop     0,2
  159. _nest_find        dc.l     *+4
  160.                   move.l   (sp),d0           ;get voc pointer
  161.                   move.l   d0,a0             ; generate flags
  162.                   beq      no                ;no words in vocabulary
  163.                   ; start by checking the length of both words
  164. 1$                move.l   4(sp),a1          ;point to word
  165.                   lea      4(a0),a2          ;point to voc-word
  166.                   move.b   (a1)+,d1          ;get length of both words
  167.                   move.b   (a2)+,d2
  168.                   eor.b    d2,d1
  169.                   andi.b   #$3f,d1           ;mask of 2 high bits
  170.                   bne.s    3$      
  171.                   ; check all characters in both words
  172. 2$                move.b   (a1)+,d1          ;get next characters
  173.                   move.b   (a2)+,d2          ; high bit set is the end
  174.                   eor.b    d2,d1
  175.                   lsl.b    #1,d1
  176.                   bne.s    3$                ;if not the same do next word
  177.                   bcc.s    2$                ; not last char yet
  178.                   ; a match, save the cfa of the found word
  179.                   move.w   a2,d0             ;a2 points to past last char
  180.                   lsr.w    #1,d0             ; must round it up
  181.                   bcc.s    4$   
  182.                   addq.l   #1,a2
  183. 4$                move.l   a2,4(sp)          ;save cfa of found word
  184.                   ; check the immediate bit and return -1 if clear
  185.                   moveq    #immediate,d0     ;mask
  186.                   and.b    4(a0),d0          ; length byte
  187.                   beq      yes               ;non-immediate,return -1
  188.                   moveq    #1,d0
  189.                   move.l   d0,(sp)
  190.                   jmp      (a3)              ;immediate return 1
  191.                   ; advance to next word in vocabulary
  192. 3$                move.l   (a0),d0
  193.                   move.l   d0,a0             ;check for zero
  194.                   bne.s    1$   
  195.                   bra      no                ;return 0 if it is.
  196.  
  197. * #threads        (s -- #threads ) Currently 4 linked lists.
  198.                   dc.w     -1
  199.                   dc.l     link3
  200. link3             set      *-4
  201.                   dc.b     $88,'#thread',$80!'s'
  202.                   cnop     0,2
  203. _number_threads   dc.l     doconstant,4
  204.  
  205. * find            (s addr -- addr false | cfa flag ) Returns the same as
  206. ; (find). This word searches through the context array of vocabularies.
  207. ; Note that if the string is null, the address of 'noop' is returned
  208. ; marked as immediate, and 'end' is set on, to indicate to the interpreter
  209. ; or compiler, that the input is ended.
  210.                   dc.w     -1
  211.                   dc.l     link2
  212. link2             set      *-4
  213.                   dc.b     $84,'fin',$80!'d'
  214.                   cnop     0,2
  215. _find             dc.l     nest
  216.                   dc.l     _dup,_c_fetch
  217.                   dc.l     _question_branch,5$
  218.                   dc.l       _prior,_off,_false,_number_vocs,_0
  219.                   dc.l       _nest_do,4$
  220. 1$                dc.l         _drop,_context,_i,_4_times
  221.                   dc.l         _plus,_fetch,_dup
  222.                   dc.l         _question_branch,3$
  223.                   dc.l            _dup,_prior,_fetch,_over
  224.                   dc.l            _prior,_store,_equals
  225.                   dc.l            _question_branch,2$
  226.                   dc.l              _drop,_false
  227.                   dc.l            _branch,3$
  228. 2$                dc.l              _over,_swap,_hash,_fetch
  229.                   dc.l              _nest_find,_dup,_nest_question_leave
  230. 3$                dc.l       _nest_loop,1$
  231. 4$                dc.l     _branch,6$
  232. 5$                dc.l       _drop,_end_question,_on
  233.                   dc.l       _nest_lit,_noop,_1
  234. 6$                dc.l     _exit
  235.  
  236. * ?uppercase      (s addr -- addr ) Convert string at address to upper case
  237. ; if caps is true.
  238.                   dc.w     -1
  239.                   dc.l     link3
  240. link3             set      *-4
  241.                   dc.b     $8a,'?uppercas',$80!'e'
  242.                   cnop     0,2
  243. _question_uppercase
  244.                   dc.l     nest
  245.                   dc.l     _caps,_fetch,_question_branch,1$
  246.                   dc.l       _dup,_count,_upper
  247. 1$                dc.l     _exit
  248.  
  249. * defined         (s -- here 0 | cfa [ -1 | +1 ] )
  250. ; Look up the next word in the input stream. Take case into account
  251. ; and return flag, and maybe cfa.
  252.                   dc.w     -1
  253.                   dc.l     link0
  254. link0             set      *-4
  255.                   dc.b     $87,'define',$80!'d'
  256.                   cnop     0,2
  257. _defined          dc.l     nest
  258.                   dc.l     _bl,_word,_question_uppercase,_find,_exit
  259.  
  260.  
  261.